;; =============================================================================
;; xhtml code converter

(defclass xcg-context ()
  (
   ;; entities map
   (types :initform (make-hash-table) :reader types)
   (funcs :initform (make-hash-table) :reader funcs)
   (constraints :initform (make-hash-table) :reader constraints)

   ;; state
   (indent-level :initform 0 :accessor indent-level)
   (newline :initform nil :accessor newline)

   ;; initial settings
   (prepend-line :initform "" :initarg :prepend-line :reader prepend-line)
   (stream :initform (error "stream is not specified") :initarg :stream :reader stream)
   ))

;; =============================================================================
;; utility functions

;; increases indentation
(defun indent (context)
  (assert (>= (indent a) 0))
  (incf (indent-level context) 2))

;; decreases indentation
(defun unindent (context)
  (decf (indent-level context) 2)
  (assert (>= (indent a) 0)))


;; generic print
(defgeneric print-cons-expr (stream id args))

(defmethod print-cons-expr (stream (id (eql 'span)) args)
  (destructuring-bind (span-class span-expr) args
    (format stream "<span class=\"~a\">~a</span>"
	    ;; return css class representation (this is to avoid unknown classes and wrong character case)
	    (case span-class
	      ('typename "typename")
	      ('keyword "keyword")
	      ('identifier "identifier")
	      ('bodyblock "bodyblock")
	      (t (error "unknown span class")))
	    span-expr)))

;; span
(defgeneric print-cons-expr (stream id args))

;; prints line of html text
(defun print-sequence (context sequence)
  (let ((stream (stream context)))
    (dolist (expr sequence)
      ;; newline check
      (if (newline context)
	(progn
	  (setf (newline context) nil)
	  (write-string (prepend-line context) stream)
	  (dotimes (i (indent-level context))
	    (write-string "&nbsp;" stream))))
      ;; print expr
      (cond
	;; expression
	((typep expr 'cons) (print-cons-expr stream (car expr) (cdr expr)))

	;; string
	((typep expr 'string) (write-string expr stream))
	
	;; symbol
	((typep expr 'symbol)
	 (case expr
	   ;; newline
	   ('newline
	    (progn
	      (format stream "<br/>~%")
	      (setf (newline context) t)))
	   ;; unknown symbol
	   (t (error (format nil "unknown symbol: ~a" expr)))
	   ))

	;; unknown expression type
	(t (error (format nil "unknown sequence expression: ~a" expr)))))))

;; =============================================================================
;; toplevel parse methods

;; generic interface
(defgeneric toplev-parse (context id args))


;; type parse, TODO: more complex handling
(defmethod toplev-parse (context (id (eql 'type)) args)
  (destructuring-bind (type-name &optional members) args
    ;; xhtml-formatted text
    (print-sequence context
		    (list "(" (list 'span 'keyword "type") " " (list 'span 'typename type-name)
			  (if members (format nil " ~a" members) "")
			  ")" 'newline))

    ;; mark this type as used one
    (setf (gethash type-name (types context)) t)))

;; func parse
(defmethod toplev-parse (context (id (eql 'func)) args)
  (destructuring-bind (func-name func-args &optional func-body) args
    (format (stream context) "(<span class=\"keyword\">func</span> <span class=\"identifier\">~a</span> (~a))~a<br/>~%"
	    func-name
	    ;; args concatenation
	    (let ((args-str ""))
	      (loop for (arg-name arg-type) in func-args do
		    (setf args-str (concatenate 'string
						args-str
						(format nil "(~a <span class=\"typename\">~a</span>)"
							arg-name arg-type))))
	      args-str)
	    ;; function body
	    (if func-body
		(format nil "<br/>~%<span>&nbsp;&nbsp;~a</span>" func-body)
		""))))

;;
;; generic+methods for func parse

;; operators block parse
(defgeneric block-parse (context id args))

(defmethod block-parse (context (id (eql 'block)) args))


;; == NONE ==

;; comments (newline and comment)
(defmethod toplev-parse (context (id (eql 'comment)) args)
  (destructuring-bind (comment-str) args
    (print-sequence context 'newline (list 'span 'comment comment-str) 'newline)))


;; =============================================================================
;; parser entry point

(defun parse (context expr-list)
  (format (stream context) "~a<div class=\"snippet\">~%<p>~%" (prepend-line context))
  (dolist (expr expr-list)
    (toplev-parse context (car expr) (cdr expr)))
  (format (stream context) "~a</p>~%</div>~%" (prepend-line context)))


(defun parse-s (expr-list)
  (parse (make-instance 'xcg-context :stream *standard-output*) expr-list))


;; == UT ==
;;(parse-s '((type Animal)))
;;(parse-s '((type Animal) (comment "data access function") (func can-fly ((animal Animal)))))


;; TODO: rewrite toplev-parser and inferiors to use print-sequence
